home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
mpfeel.lha
/
MPFeel
/
Modules
/
heapv2.em
< prev
next >
Wrap
Lisp/Scheme
|
1992-10-06
|
22KB
|
713 lines
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; EuLisp Module Copyright (C) University of Bath 1991 ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmodule heapv2
(futures
threads
semaphores
arith
lists
extras
vectors
list-operators
streams
) ()
(setq lista1 nil)
(setq lista2 nil)
(setq seed 253)
(setq seed2 867)
(defun >= (x y)
(not (< x y))
)
(defun <= (x y)
(not (> x y))
)
(defun random100 ()
(progn
(setq seed (modulo (+ (* seed 1213) 277) 149))
(modulo seed 100)
)
)
(defun random30 ()
(progn
(setq seed2 (modulo (+ (* seed2 3247) 913) 97))
(+ (modulo seed2 13) 1)
)
)
(defun create_pet (n)
(create_pet_aux () n 0)
)
(defun cont (x y)
(if (equal x nil)
nil
(if (or
(and (>= (car y) (caar x)) (< (car y) (+ (caar x) (cdar x))))
(and (>= (caar x) (car y)) (< (caar x) (+ (car y) (cdr y))))
)
t
(cont (cdr x) y)
)
)
)
(defun create_pet_aux (x n c)
(if (not (< c n))
x
(prog (a b)
loop1
(setq a (random100))
(setq b (random30))
(if (> (+ a b) 100) (go loop1) nil)
(if (cont x (cons a b)) (go loop1)
(if (= 0 (modulo c 2))
(progn
(setq lista1 (append lista1 (list (cons a b))))
(create_pet_aux (append x (list (cons a b))) n (+ c 1))
)
(progn
(setq lista2 (append lista2 (list (cons a b))))
(create_pet_aux (append x (list (cons a b))) n (+ c 1))
)
)
)
)
)
)
(defun scheduler (n)
(create_pet n)
(print lista1)
(print lista2)
(progn (future (process)) (process2))
)
(defun process ()
(setq item (car lista))
(setq lista (cdr lista))
(if (null lista) (setq fin t) (setq fin f))
(insblk (car item) (cdr item))
(if fin nil (process))
)
(defun process2 ()
(setq item (car lista2))
(setq lista2 (cdr lista2))
(if (null lista2) (setq fin t) (setq fin f))
(insblk (car item) (cdr item))
(if fin nil (process2))
)
;;; Rutinas de test de las inserciones y supresiones en el arbol.
;;; Test(n) genera n inserciones aleatorias,haciendo una supresion aleatoria
;;; cada 4 inserciones a partir de la segunda.
(defun test (n)
(test-aux (create_pet n) 0)
)
(defun test-aux (x n)
(print "*************************************")
(print (car x))
(insblk (caar x) (cdar x))
(print tuple_root)
(if (= (modulo n 4) 2)
(progn
(print "####################################")
(setq z (random30))
(print z)
(getblk z)
(print tuple_root)
)
nil
)
(if (equal (cdr x) nil)
nil
(test-aux (cdr x) (+ n 1))
)
)
;;; Constant definition
(defconstant block_size 5)
(defconstant b_lock 0)
(defconstant b_left 1)
(defconstant b_right 2)
(defconstant b_addr 3)
(defconstant b_len 4)
(defconstant l_child t)
(defconstant r_child nil)
(defconstant heap_size 100)
(defconstant heap_base_addr 0)
(defconstant extra_big (+ 1 heap_size))
;;; Function definition
(defun free (node)
(print "entro en free")
(if (not (= 1 (vector-ref node b_lock)))
(progn
(print "******************************************************")
(print "Trying to free a node that is not locked")
(print "******************************************************")
)
nil
)
(vector-ref-updator node b_lock 0)
(print "salgo de free")
)
(defun <= (x y) (not (> x y))) ;;; Do these functions exist ???
(defun >= (x y) (not (< x y)))
;;; Nodes are marked when they are accesed by the functions left and right.
;;; They are not marked by the functions leftw and rightw (the process
;;; just waits for them to be free before operating on them).
(defun left (x)
(prog (var)
(print "Entrando en left y la x vale : ")
(print x)
(if (not (= 1 (vector-ref x b_lock)))
(progn
(print "***********************************************")
(print "Trying to get the left child without locking the parent")
(print "***********************************************")
)
nil
)
(setq var (vector-ref x b_left))
(if (null var) (return nil) nil)
lb (cond ( (= (vector-ref var b_lock) 0)
(vector-ref-updator var b_lock 1)
(return var)
)
( t (go lb))
)
)
)
(defun leftw (x)
(prog (var)
(setq var (vector-ref x b_left))
(if (null var) (return nil) nil)
lb (cond ( (= (vector-ref var b_lock) 0)
(return var)
)
( t (go lb))
)
)
)
(defun right (x)
(prog (var)
(print "Entrando en right la x vale : ")
(print x)
(if (not (= 1 (vector-ref x b_lock)))
(progn
(print "***********************************************")
(print "Trying to get the right child without locking the parent")
(print "***********************************************")
)
nil
)
(setq var (vector-ref x b_right))
(if (null var) (return nil) nil)
lb (cond ( (= (vector-ref var b_lock) 0)
(vector-ref-updator var b_lock 1)
(return var)
)
( t (go lb))
)
)
)
(defun rightw (x)
(prog (var)
(setq var (vector-ref x b_right))
(if (null var) (return nil) nil)
lb (cond ( (= (vector-ref var b_lock) 0)
(return var)
)
( t (go lb))
)
)
)
(defun addr (x) (vector-ref x b_addr ))
(defun len (x) (vector-ref x b_len ))
(defun leftkkk (x y) (vector-ref-updator x b_left y))
(defun rightkkk (x y) (vector-ref-updator x b_right y))
(defun addrkkk (x y) (vector-ref-updator x b_addr y))
(defun lenkkk (x y) (vector-ref-updator x b_len y))
(defun to_the_left_of (a b)
(< (addr a) (addr b)))
(defun coalesces (left right)
(= (+ (addr left) (len left)) (addr right)))
(defun ok4size (parent child)
(>= (len parent) (len child)))
(defun add2len (old new)
(lenkkk old (+ (len old) (len new))))
(defun fixparent (p waslft new) ; update either left or right of a node
(if waslft (leftkkk p new )
(rightkkk p new)
)
)
; pretend that root is arbitrarily large to get insert to coalesce correctly on
; first real node
(defun make_block (base length)
(let ((new (make-vector block_size nil)))
(vector-ref-updator new b_lock 0)
(addrkkk new base)
(lenkkk new length)
new
)
)
(defun setup_tuple_heap ()
(setq tuple_root (make_block (+ heap_base_addr heap_size) extra_big))
(leftkkk tuple_root (make_block heap_base_addr heap_size))
(setq sem (make-semaphore))
(initialize-semaphore sem)
;;; Inicialitzar el semafor de l'arrel, posteriorment caldra fer servir un
;;; semafor de veritat.
)
(setup_tuple_heap) ; set up made when loading the module
(defun insblk (adr leng)
(setq v (make-vector 5 nil))
(vector-ref-updator v b_lock 1) ;the block to be inserted is locked
(addrkkk v adr)
(lenkkk v leng)
;;; Wait del semafor de l'arrel de l'arbre.De moment no es fa com cal.
(open-semaphore sem)
(insert tuple_root l_child (left tuple_root) v)
)
(defun insertfromroot (new)
(rightkkk new nil)
(leftkkk new nil)
;;; Wait del semafor de l'arrel de l'arbre.Solucio temporal.
(open-semaphore sem)
(insert tuple_root l_child (left tuple_root ) new )
)
(defun getblk(size)
;;; Wait del semafor de l'arrel de l'arbre.Encara no ben fet.
(open-semaphore sem)
(let ((l_son (left tuple_root)))
(if (null l_son)
(progn
(print "Sorry,no memory left")
(close-semaphore sem)
;;; Fer el signal del semafor de l'arrel.
nil
)
(progn
(cond ((> size (len l_son))
(print "No large enough block exists.")
(print " Max : ")
(print (len l_son))
(print " Request : ")
(print size)
(free l_son)
(close-semaphore sem)
;;; Signal del semafor de l'arrel,treure in-use fill esquerre.
nil
)
(t
(getblk1 size l_son tuple_root t)
)
)
)
)
)
)
(defun getblk1 (size ptr last waslft)
; get a block of size from a descendant of ptr if
; possible, or split ptr otherwise
(let ((l (left ptr)) (r (right ptr)))
(cond ((and (not (null l))
(<= size (len l)))
(if (= 100 (addr last)) (close-semaphore sem) (free last))
(if (not (null r)) (free r) nil)
;;;en aquest punt alliberar r i last
(getblk1 size l ptr t)) ; get from left hand child
((and (not (null r))
(<= size (len r)))
;;; en aquest punt alliberar last i l
(if (not (null l)) (free l) nil)
(if (= 100 (addr last)) (close-semaphore sem) (free last))
(getblk1 size r ptr nil)) ; get from right hand child
(t
(if (not (null l)) (free l) nil)
(if (not (null r)) (free r) nil)
;;; en aquest punt alliberar l i r
(splitblk size ptr last waslft))
)
)
)
(defun splitblk (size ptr last waslft) ; allocate a block of size from the end
; of ptr and make ptr smaller
(let* ((l (len ptr)) (over (- l size))
(new (make_block (+ (addr ptr) over) size)))
;;; atencio, new es un node que es fabrica nomes per a retornar a l'usuari
;;; pero que mai no s'incorpora a l'arbre...No cal marcar-lo ni res.
(cond ((= 0 over) ; asked for the whole block
(delfixup last waslft (left ptr) (right ptr))
;;;Aqui no cal alliberar res
; should perhaps null out left and right in ptr
(leftkkk ptr 'void)
(rightkkk ptr 'void)
(free ptr) ;innecesari,ningu hauria de poder arribar a ptr mai mes
;;; Aqui alliberar ptr
new)
(t
(lenkkk ptr over) ; make ptr smaller
(reheapify last waslft ptr)
new)
)
)
)
(defun reheapify (parent waslft ptr)
; ptr may be too small, but is ok for addressing
(print "Entro en reheapify")
(print parent)
(print ptr)
(let* ((a (left ptr)) (b (right ptr)) (plen (len ptr))
(abig (and (not (null a)) ; abig true if left child too big
(> (len a) plen)))
(bbig (and (not (null b)) ; bbig true if right child too big
(> (len b) plen))))
(cond ((not abig)
(cond ((not bbig)
(if (not (null a)) (free a) nil)
(if (not (null b)) (free b) nil)
(free ptr)
(if (= 100 (addr parent)) (close-semaphore sem) (free parent))
nil
) ; ptr was actually ok
(t
; right hand child is bigger, left isn't
(fixparent parent waslft b) ; parent points to old right
(if (= 100 (addr parent)) (close-semaphore sem) (free parent))
(leftkkk ptr a) ; hang old left onto left of ptr
(if (not (null a)) (free a) nil)
(rightkkk ptr (leftw b)) ; and left of old right on right
(leftkkk b ptr) ; and put ptr as left of old right
(reheapify b l_child ptr)))) ; now check that
(t ; left child is bigger than ptr
(cond ((not bbig) ; and right isn't
(fixparent parent waslft a) ; parent points to old left
(if (= 100 (addr parent)) (close-semaphore sem) (free parent))
(rightkkk ptr b) ; hang old right onto right of ptr
(if (not (null b)) (free b) nil)
(leftkkk ptr (rightw a)) ; and right of old left on left
(rightkkk a ptr) ; and put ptr as right of old left
(reheapify a r_child ptr)) ; now check that
; both a children are bigger, so must put correct one on top
((> (len a) (len b)) ; left is bigger than right
(fixparent parent waslft a) ; see comments above
(if (= 100 (addr parent)) (close-semaphore sem) (free parent))
(rightkkk ptr b)
(if (not (null b)) (free b) nil)
(leftkkk ptr (rightw a))
(rightkkk a ptr)
(reheapify a r_child ptr))
(t
(fixparent parent waslft b)
(if (= 100 (addr parent)) (close-semaphore sem) (free parent))
(leftkkk ptr a)
(if (not (null a)) (free a) nil)
(rightkkk ptr (leftw b))
(leftkkk b ptr)
(reheapify b l_child ptr)
)
)
)
)
)
)
(defun delfixup (parent waslft a b)
(print "entro en delfixup")
(print parent)
(print a)
(print b)
; we've deleted a node, so we've got a dangling pointer and two orphans.
(cond ((null a)
;;; no cal alliberar a doncs si es null llavors no hi ha in_use...
; no left child
(if (null b)
;;; el mateix d'abans aplicat a b
(progn
(fixparent parent waslft nil) ; no children so make into a leaf
(if (= 100 (addr parent)) (close-semaphore sem) (free parent))
)
(progn
(fixparent parent waslft b) ; attach old right child
(free b)
(if (= 100 (addr parent)) (close-semaphore sem) (free parent))
)
)
)
;;; alliberar parent i b si no era null
;;; s'ha fet introduint progn per a sequenciar...
(t
(if (null b)
;;; no alliberar b, doncs era null
(progn
(fixparent parent waslft a) ; no right child
(if (= 100 (addr parent)) (close-semaphore sem) (free parent))
(free a)
)
;;; alliberar parent i a ; tambe fet amb progn
; hard case, there are two children, so do a rotate
(cond ((> (len a) (len b)) ; old left is bigger, so
(fixparent parent waslft a) ; dangling now to old left
(if (= 100 (addr parent)) (close-semaphore sem) (free parent))
;;; alliberar parent
(delfixup a r_child (right a) b)) ; fixup right of old left
; wrt old right of old left
; and old right
(t ; old right is bigger, so
(fixparent parent waslft b) ; dangling now to old right
(if (= 100 (addr parent)) (close-semaphore sem) (free parent))
;;; alliberar parent
(delfixup b l_child a (left b)))))))
(print "salgo de delfixup")
)
(defun delfixupnm (parent waslft a b)
(print "entro en delfixupnm")
(print parent)
(print a)
(print b)
; we've deleted a node, so we've got a dangling pointer and two orphans.
(cond ((null a)
;;; no cal alliberar a doncs si es null llavors no hi ha in_use...
; no left child
(if (null b)
;;; el mateix d'abans aplicat a b
(progn
(fixparent parent waslft nil) ; no children so make into a leaf
)
(progn
(fixparent parent waslft b) ; attach old right child
)
)
)
;;; alliberar parent i b si no era null
;;; s'ha fet introduint progn per a sequenciar...
(t
(if (null b)
;;; no alliberar b, doncs era null
(progn
(fixparent parent waslft a) ; no right child
)
;;; alliberar parent i a ; tambe fet amb progn
; hard case, there are two children, so do a rotate
(cond ((> (len a) (len b)) ; old left is bigger, so
(fixparent parent waslft a) ; dangling now to old left
;;; alliberar parent
(delfixupnm a r_child (rightw a) b)) ; fixup right of old left
; wrt old right of old left
; and old right
(t ; old right is bigger, so
(fixparent parent waslft b) ; dangling now to old right
;;; alliberar parent
(delfixupnm b l_child a (leftw b)))))))
(print "salgo de delfixupnm")
)
; fixup left of old right wrt old left and old left of old right
; insert is the hardest of all. When inserting a block it may coalesce with
; 0, 1 or 2 existing blocks. If we have just performed a coalescence then the
; other coalescing block (if it exists) is in one of the children; found by
; leftc or rightc.
(defun leftc (parent waslft node end_addr) ; find a block ending at end_addr
;starting from node. If such a block exists it is the rightmost descendant,
;and its left child (if any) can be spliced in in its place.
(cond ((null node) nil)
((= (+ (addr node) (len node)) end_addr) ; it does coalesce
(fixparent parent waslft (leftw node)) ;delete node and reconnect left
node)
(t
(leftc node r_child (rightw node) end_addr)
)
)
)
(defun rightc (parent waslft node start_addr) ;find a block starting at
;start_addr from node, going left
(cond ((null node) nil)
((= (addr node) start_addr) ; it does coalesce
(fixparent parent waslft (rightw node)) ;delete node and reconnect right
node)
(t
(rightc node l_child (leftw node) start_addr)
)
)
)
; partition takes a tree (node), and a pivot element. It returns a tree, the
; root of which is pivot (with any coalescing blocks added to it), and whose
; children are correct wrt the root.
(defun partition (node pivot)
; partition returns a node whose left and right children are correct
; the node is the (modified) pivot
(print "entro en partition")
(print node)
(cond ((null node)
(leftkkk pivot nil)
(rightkkk pivot nil)
pivot)
((to_the_left_of node pivot)
(cond ((coalesces node pivot) ; pivot joins onto right end of node
(add2len node pivot) ; merge node into pivot
(let ((rc (rightc node r_child (rightw node)
(+ (addr node) (len node)))))
; rc modifies right branch in place
(cond ((not (null rc)) ;rc goes on right of new
(add2len node rc))))
node) ; node now has correct left and right children
(t ; node clear to left of pivot
; thus the left children of node are ok
(let ((part (partition (rightw node) pivot)))
; now transfer the left child of part to be right child of node
(rightkkk node (leftw part))
(leftkkk part node) ; and make node the left child of part
part))))
(t
(cond ((coalesces pivot node) ; new joins to left of node
(addrkkk node (addr pivot)) ; node now begins at new
(add2len node pivot) ; merge new into node
(let ((lc (leftc node l_child (leftw node)
(addr node))))
(cond ((not (null lc)) ; lc goes on left of node
(addrkkk node (addr lc))
(add2len node lc))))
node)
(t ; node clear to right of pivot
; thus the right children of node are ok
(let ((part (partition (leftw node) pivot)))
; now transfer the right child of part to be left child of node
(leftkkk node (rightw part))
(rightkkk part node) ; and make node the right child of part
part)))))
)
(defun insert (parent waslft node new)
(cond ((null node) ; make new into a leaf
(fixparent parent waslft new)
;;; alliberem parent,no cal alliberar node perque es nul
(if (= 100 (addr parent)) (close-semaphore sem) (free parent))
(free new) ;;; bloc a insertar,esta marcat
)
((and (not (coalesces node new)) ; if it coalesces we call partition
(not (coalesces new node)) ; lazy, but the loss isn't much
(> (len node) (len new))) ; we aren't big enough
;;;aqui es pot alliberar parent, abans de fer el cond
(if (= 100 (addr parent)) (close-semaphore sem) (free parent))
(cond ((< (addr new) (addr node)) ; node goes on left of new
(insert node l_child (left node) new))
(t ; new on the left of node
(insert node r_child (right node) new))))
(t
; could be a coalescence
; new is now not smaller than node, so put it in place of node,
; partition the appropriate descendent, and fix up.
; we insert as soon as we can so thatif a coalescence occurs
; there's a chance we still fit.
(free new)
(free node)
(let ((p (partition node new)))
(cond ((ok4size parent p)
(fixparent parent waslft p)
;;; alliberar parent
(if (= 100 (addr parent)) (close-semaphore sem) (free parent))
) ;we fit here,so fixup and leave
(t
(delfixupnm parent waslft (left p) (right p)) ; delete us
(if (= 100 (addr parent)) (close-semaphore sem) (free parent))
(vector-ref-updator p b_lock 1)
(print " >>>>>>>>>>>>>>>>> reinserto <<<<<<<<<<<<<<<")
(insertfromroot p) ; and start again
)
)
)
)
)
)
; note that the reinsertion from root cannot cause a coalescence, and thus
; simplified code could be used. fix it later maybe.
(export insblk getblk test scheduler)
)
